Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue71/Alfresco/TstRadix.dpr

Text File | 2001-06-03 | 18.3 KB | 690 lines

{*********************************************************}
{* TstRadix                                              *}
{* Copyright (c) Julian M Bucknall 2001                  *}
{* All rights reserved.                                  *}
{*********************************************************}
{* Algorithms Alfresco: Radix sorts                      *}
{*********************************************************}

{Note: this unit is released as freeware. In other words, you are free
       to use this unit in your own applications, however I retain all
       copyright to the code. JMB}

program TstRadix;

{$APPTYPE CONSOLE}

uses
  SysUtils,
  Classes,
  Windows;

const
  ItemListCount = 100000;

type
  DWordAsBytes = array [0..3] of byte;

{====================================================================}
type
  PaaItemByteKey = ^TaaItemByteKey;
  TaaItemByteKey = record
    ibkData : string;  // the data
    ibkKey  : byte;    // the key
  end;
  PaaItemByteKeyList = ^TaaItemByteKeyList;
  TaaItemByteKeyList = array [0..pred(ItemListCount)] of TaaItemByteKey;

procedure aaDistributionSort;
var
  i : integer;
  ItemList : PaaItemByteKeyList;
  AuxList  : PaaItemByteKeyList;
  Counter : array [0..255] of integer;
  PrevData : string;
  PrevKey  : byte;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('Distribution sort on a byte key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemByteKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := random(256);
  end;
  writeln('..done, now starting sort...');
  StartTime := GetTickCount;

  {clear the counter array}
  FillChar(Counter, sizeof(Counter), 0);

  {calculate the distribution of each key}
  for i := 0 to pred(ItemListCount) do
    inc(Counter[ItemList^[i].ibkKey]);

  {calculate the cumulative distribution}
  for i := 1 to 255 do
    inc(Counter[i], Counter[i-1]);

  {create the auxiliary list}
  New(AuxList);

  {copy over the items to the auxiliary list in sorted order}
  for i := pred(ItemListCount) downto 0 do begin
    dec(Counter[ItemList^[i].ibkKey]);
    AuxList^[Counter[ItemList^[i].ibkKey]] := ItemList^[i];
  end;
  EndTime := GetTickCount;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevData := '';
  PrevKey := 0;
  for i := 0 to pred(ItemListCount) do begin
    if (AuxList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else if (AuxList^[i].ibkKey = PrevKey) then begin
      if (AuxList^[i].ibkData <= PrevData) then begin
        writeln('Error: sort not stable');
        readln;
      end;
      PrevData := AuxList^[i].ibkData;
    end
    else begin
      PrevKey := AuxList^[i].ibkKey;
      PrevData := AuxList^[i].ibkData;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(AuxList^[i].ibkKey:3, AuxList^[i].ibkData:12);

  Finalize(ItemList^);
  FreeMem(ItemList);
  Finalize(AuxList^);
  FreeMem(AuxList);
end;
{====================================================================}


{====================================================================}
type
  PaaItemStrKey = ^TaaItemStrKey;
  TaaItemStrKey = record
    ibkData : string;     // the data
    ibkKey  : string[9];  // the key
  end;
  PaaItemStrKeyList = ^TaaItemStrKeyList;
  TaaItemStrKeyList = array [0..pred(ItemListCount)] of TaaItemStrKey;

function GetRandomString : string;
var
  i : integer;
begin
  SetLength(Result, random(5) + 5);
  for i := 1 to length(Result) do
    Result[i] := char(random(26) + ord('a'));
end;

procedure MSD(aFromList, aToList : PaaItemStrKeyList;
              aFirst, aLast : integer;
              aCharInx : integer);
var
  i : integer;
  Inx : integer;
  Counter : array [0..255] of integer;
  Bins    : array [-1..255] of integer;
begin
  {exit if we reached the maximum character position}
  if (aCharInx > 9) then
    Exit;

  {if there's only one item, just exit: there's nothing to do}
  if (aLast = aFirst) then
    Exit;

  {clear the counter array}
  FillChar(Counter, sizeof(Counter), 0);

  {calculate the distribution of each key}
  for i := aFirst to aLast do
    if (length(aFromList^[i].ibkKey) < aCharInx) then
      inc(Counter[0])
    else
      inc(Counter[byte(aFromList^[i].ibkKey[aCharInx])]);

  {calculate the cumulative distribution}
  Bins[-1] := 0;
  Bins[0] := Counter[0];
  for i := 1 to 255 do begin
    inc(Counter[i], Counter[i-1]);
    Bins[i] := Counter[i];
  end;

  {copy over the items to the "to" list in sorted order}
  for i := aLast downto aFirst do begin
    if (length(aFromList^[i].ibkKey) < aCharInx) then begin
      dec(Counter[0]);
      aToList^[aFirst + Counter[0]] := aFromList^[i];
    end
    else begin
      Inx := byte(aFromList^[i].ibkKey[aCharInx]);
      dec(Counter[Inx]);
      aToList^[aFirst + Counter[Inx]] := aFromList^[i];
    end;
  end;

  {move the sorted data back}
  Move(aToList^[aFirst], aFromList^[aFirst],
       succ(aLast - aFirst) * sizeof(TaaItemStrKey));

  {recursively sort each of the bins}
  for i := 0 to 255 do begin
    if (Bins[i] > Bins[i-1]) then
      MSD(aFromList, aToList,
          aFirst + Bins[i-1], aFirst + pred(Bins[i]),
          succ(aCharInx));
  end;
end;

procedure aaMSDRadixSortStr;
var
  i : integer;
  ItemList : PaaItemStrKeyList;
  AuxList  : PaaItemStrKeyList;
  PrevKey  : string;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('MSD radix sort on a string key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemStrKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := GetRandomString;
  end;
  writeln('..done, now starting sort...');

  {get time}
  StartTime := GetTickCount;

  {allocate the auxiliary array}
  New(AuxList);

  {sort the items}
  MSD(ItemList, AuxList, 0, pred(ItemListCount), 1);

  {move them back}
  EndTime := GetTickCount;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevKey := '';
  for i := 0 to pred(ItemListCount) do begin
    if (ItemList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else begin
      PrevKey := ItemList^[i].ibkKey;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(ItemList^[i].ibkKey);

  Finalize(ItemList^);
  FreeMem(ItemList);
  Finalize(AuxList^);
  FreeMem(AuxList);
end;


procedure aaLSDRadixSortStr;
var
  i : integer;
  Inx      : integer;
  CharInx  : integer;
  ItemList : PaaItemStrKeyList;
  AuxList  : PaaItemStrKeyList;
  FromList : PaaItemStrKeyList;
  ToList   : PaaItemStrKeyList;
  Temp     : PaaItemStrKeyList;
  Counter  : array [0..255] of integer;
  PrevKey  : string;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('LSD radix sort on a string key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemStrKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := GetRandomString;
  end;
  writeln('..done, now starting sort...');

  {get time}
  StartTime := GetTickCount;

  {allocate the auxiliary array}
  New(AuxList);

  {prepare for the loop}
  FromList := ItemList;
  ToList := AuxList;

  {for each character in the key strings, from end to start...}
  for CharInx := 9 downto 1 do begin

    {clear the counter array}
    FillChar(Counter, sizeof(Counter), 0);

    {calculate the distribution of each key}
    for i := 0 to pred(ItemListCount) do
      if (length(FromList^[i].ibkKey) < CharInx) then
        inc(Counter[0])
      else
        inc(Counter[byte(FromList^[i].ibkKey[CharInx])]);

    {calculate the cumulative distribution}
    for i := 1 to 255 do
      inc(Counter[i], Counter[i-1]);

    {copy over the items to the "to" list in sorted order}
    for i := pred(ItemListCount) downto 0 do begin
      if (length(FromList^[i].ibkKey) < CharInx) then begin
        dec(Counter[0]);
        ToList^[Counter[0]] := FromList^[i];
      end
      else begin
        Inx := byte(FromList^[i].ibkKey[CharInx]);
        dec(Counter[Inx]);
        ToList^[Counter[Inx]] := FromList^[i];
      end;
    end;

    {switch over the to and from.lists}
    Temp := FromList;
    FromList := ToList;
    ToList := Temp;
  end;
  if (FromList <> ItemList) then
    Move(FromList^, ItemList^, sizeof(FromList^));
  EndTime := GetTickCount;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevKey := '';
  for i := 0 to pred(ItemListCount) do begin
    if (ItemList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else begin
      PrevKey := FromList^[i].ibkKey;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(ItemList^[i].ibkKey);

  Finalize(ItemList^);
  FreeMem(ItemList);
  Finalize(AuxList^);
  FreeMem(AuxList);
end;
{====================================================================}


{====================================================================}
procedure QSS(aList    : PaaItemStrKeyList;
              aFirst   : integer;
              aLast    : integer);
var
  L, R  : integer;
  Pivot : string[9];
  Temp  : TaaItemStrKey;
begin
  {while there are at least two items to sort}
  while (aFirst < aLast) do begin
    {the pivot string is from the middle item}
    Pivot := aList^[(aFirst+aLast) div 2].ibkKey;
    {set indexes and partition}
    L := pred(aFirst);
    R := succ(aLast);
    while true do begin
      repeat dec(R); until (aList^[R].ibkKey <= Pivot);
      repeat inc(L); until (aList^[L].ibkKey >= Pivot);
      if (L >= R) then Break;
      Temp := aList^[L];
      aList^[L] := aList^[R];
      aList^[R] := Temp;
    end;
    {quicksort the first subfile}
    if (aFirst < R) then
      QSS(aList, aFirst, R);
    {quicksort the second subfile - recursion removal}
    aFirst := succ(R);
  end;
end;

procedure aaStrQuickSort;
var
  i : integer;
  ItemList : PaaItemStrKeyList;
  PrevKey  : string;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('Quicksort on a string key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemStrKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := GetRandomString;
  end;
  writeln('..done, now starting sort...');

  {get time}
  StartTime := GetTickCount;

  {sort}
  QSS(ItemList, 0, pred(ItemListCount));

  {finish}
  EndTime := GetTickCount;
  writeln;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevKey := '';
  for i := 0 to pred(ItemListCount) do begin
    if (ItemList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else begin
      PrevKey := ItemList^[i].ibkKey;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(ItemList^[i].ibkKey);

  Finalize(ItemList^);
  FreeMem(ItemList);
end;
{====================================================================}


{====================================================================}
type
  PaaItemU32Key = ^TaaItemU32Key;
  TaaItemU32Key = record
    ibkData : string;    // the data
    ibkKey  : longword;  // the key
  end;
  PaaItemU32KeyList = ^TaaItemU32KeyList;
  TaaItemU32KeyList = array [0..pred(ItemListCount)] of TaaItemU32Key;

function GetRandomU32 : longword;
var
  i : integer;
begin
  for i := 0 to 3 do
    DWordAsBytes(Result)[i] := random(256);
end;

procedure aaLSDRadixSortU32;
var
  i : integer;
  Inx      : integer;
  CharInx  : integer;
  ItemList : PaaItemU32KeyList;
  AuxList  : PaaItemU32KeyList;
  FromList : PaaItemU32KeyList;
  ToList   : PaaItemU32KeyList;
  Temp     : PaaItemU32KeyList;
  Counter  : array [0..255] of integer;
  PrevKey  : longword;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('LSD radix sort on an unsigned 32-bit key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemStrKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := GetRandomU32;
  end;
  writeln('..done, now starting sort...');

  {get time}
  StartTime := GetTickCount;

  {allocate the auxiliary array}
  New(AuxList);

  {prepare for the loop}
  FromList := ItemList;
  ToList := AuxList;

  {for each digit in the key longwords, from start to end...}
  for CharInx := 0 to 3 do begin

    {clear the counter array}
    FillChar(Counter, sizeof(Counter), 0);

    {calculate the distribution of each key}
    for i := 0 to pred(ItemListCount) do
      inc(Counter[DWordAsBytes(FromList^[i].ibkKey)[CharInx]]);

    {calculate the cumulative distribution}
    for i := 1 to 255 do
      inc(Counter[i], Counter[i-1]);

    {copy over the items to the "to" list in sorted order}
    for i := pred(ItemListCount) downto 0 do begin
      Inx := DWordAsBytes(FromList^[i].ibkKey)[CharInx];
      dec(Counter[Inx]);
      ToList^[Counter[Inx]] := FromList^[i];
    end;

    {switch over the to and from.lists}
    Temp := FromList;
    FromList := ToList;
    ToList := Temp;
  end;
  EndTime := GetTickCount;
  writeln;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevKey := 0;
  for i := 0 to pred(ItemListCount) do begin
    if (ItemList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else begin
      PrevKey := FromList^[i].ibkKey;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(ItemList^[i].ibkKey);

  Finalize(ItemList^);
  FreeMem(ItemList);
  Finalize(AuxList^);
  FreeMem(AuxList);
end;
{====================================================================}


{====================================================================}
type
  PaaItemS32Key = ^TaaItemS32Key;
  TaaItemS32Key = record
    ibkData : string;    // the data
    ibkKey  : longint;   // the key
  end;
  PaaItemS32KeyList = ^TaaItemS32KeyList;
  TaaItemS32KeyList = array [0..pred(ItemListCount)] of TaaItemS32Key;

function GetRandomS32 : longword;
var
  i : integer;
begin
  for i := 0 to 3 do
    DWordAsBytes(Result)[i] := random(256);
end;

procedure aaLSDRadixSortS32;
var
  i : integer;
  Inx      : integer;
  CharInx  : integer;
  ItemList : PaaItemS32KeyList;
  AuxList  : PaaItemS32KeyList;
  FromList : PaaItemS32KeyList;
  ToList   : PaaItemS32KeyList;
  Temp     : PaaItemS32KeyList;
  Counter  : array [0..255] of integer;
  PrevKey  : longint;
  StartTime : dword;
  EndTime   : dword;
begin
  writeln('LSD radix sort on a signed 32-bit key');

  {create an array of items with random keys to be sorted}
  writeln('..building array to be sorted');
  ItemList := Allocmem(sizeof(TaaItemStrKeyList));
  for i := 0 to pred(ItemListCount) do begin
    ItemList^[i].ibkData := Format('Item %5d', [i]);
    ItemList^[i].ibkKey := GetRandomS32;
  end;
  writeln('..done, now starting sort...');

  {get time}
  StartTime := GetTickCount;

  {allocate the auxiliary array}
  New(AuxList);

  {prepare for the loop}
  FromList := ItemList;
  ToList := AuxList;

  {for each digit in the key longwords, from start to end...}
  for CharInx := 0 to 3 do begin

    {clear the counter array}
    FillChar(Counter, sizeof(Counter), 0);

    {calculate the distribution of each key}
    if (CharInx = 3) then
      for i := 0 to pred(ItemListCount) do begin
        Inx := (DWordAsBytes(FromList^[i].ibkKey)[CharInx]) xor $80;
        inc(Counter[Inx]);
      end
    else
      for i := 0 to pred(ItemListCount) do begin
        Inx := DWordAsBytes(FromList^[i].ibkKey)[CharInx];
        inc(Counter[Inx]);
      end;

    {calculate the cumulative distribution}
    for i := 1 to 255 do
      inc(Counter[i], Counter[i-1]);

    {copy over the items to the "to" list in sorted order}
    if (CharInx = 3) then
      for i := pred(ItemListCount) downto 0 do begin
        Inx := (DWordAsBytes(FromList^[i].ibkKey)[CharInx]) xor $80;
        dec(Counter[Inx]);
        ToList^[Counter[Inx]] := FromList^[i];
      end
    else
      for i := pred(ItemListCount) downto 0 do begin
        Inx := DWordAsBytes(FromList^[i].ibkKey)[CharInx];
        dec(Counter[Inx]);
        ToList^[Counter[Inx]] := FromList^[i];
      end;

    {switch over the to and from.lists}
    Temp := FromList;
    FromList := ToList;
    ToList := Temp;
  end;
  EndTime := GetTickCount;
  writeln;
  writeln('..done (', EndTime - StartTime, ' millisecs)');
  writeln('..checking sort order...');

  PrevKey := -MaxLongInt;
  for i := 0 to pred(ItemListCount) do begin
    if (ItemList^[i].ibkKey < PrevKey) then begin
      writeln('Error: key out of sequence');
      readln;
    end
    else begin
      PrevKey := FromList^[i].ibkKey;
    end;
  end;
  writeln('..done');

//  for i := 0 to pred(ItemListCount) do
//    writeln(ItemList^[i].ibkKey);

  Finalize(ItemList^);
  FreeMem(ItemList);
  Finalize(AuxList^);
  FreeMem(AuxList);
end;
{====================================================================}



begin
  try
    writeln('Radix sort testing');

    aaDistributionSort;

    aaMSDRadixSortStr;

    aaLSDRadixSortStr;
    aaStrQuicksort;

    aaLSDRadixSortU32;
    aaLSDRadixSortS32;

    writeln('Tests completed');
  except
    on E : Exception do
      writeln(E.Message);
  end;
  readln;
end.